home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / dbutil.scm < prev    next >
Text File  |  1999-04-19  |  9KB  |  271 lines
  1. ;;; "dbutil.scm" relational-database-utilities
  2. ; Copyright 1994, 1995, 1997 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'relational-database)
  21. (require 'common-list-functions)
  22.  
  23. (define (db:base-type path)
  24.   'alist-table)                ; currently the only one.
  25.  
  26. (define (dbutil:wrap-command-interface rdb)
  27.   (and rdb
  28.        (let* ((rdms:commands ((rdb 'open-table) '*commands* #f))
  29.           (command:get
  30.            (and rdms:commands (rdms:commands 'get 'procedure))))
  31.      (and command:get
  32.           (letrec ((wdb (lambda (command)
  33.                   (let ((com (command:get command)))
  34.                 (cond (com ((slib:eval com) wdb))
  35.                       (else (rdb command)))))))
  36.         (let ((init (wdb '*initialize*)))
  37.           (if (procedure? init) init wdb)))))))
  38.  
  39. (define (dbutil:open-database! path . arg)
  40.   (let ((type (if (null? arg) (db:base-type path) (car arg))))
  41.     (require type)
  42.     (dbutil:wrap-command-interface
  43.      (((make-relational-system (slib:eval type)) 'open-database)
  44.       path #t))))
  45.  
  46. (define (dbutil:open-database path . arg)
  47.   (let ((type (if (null? arg) (db:base-type path) (car arg))))
  48.     (require type)
  49.     (dbutil:wrap-command-interface
  50.      (((make-relational-system (slib:eval type)) 'open-database)
  51.       path #f))))
  52.  
  53. (define (dbutil:create-database path type)
  54.   (require type)
  55.   (let ((rdb (((make-relational-system (slib:eval type)) 'create-database)
  56.           path)))
  57.     (dbutil:define-tables
  58.      rdb
  59.      '(type
  60.        ((name symbol))
  61.        ()
  62.        ((atom)
  63.     (symbol)
  64.     (string)
  65.     (number)
  66.     (money)
  67.     (date-time)
  68.     (boolean)
  69.     (foreign-key)
  70.     (expression)
  71.     (virtual)))
  72.      '(parameter-arity
  73.        ((name symbol))
  74.        ((predicate? expression)
  75.     (procedure expression))
  76.        ((single (lambda (a) (and (pair? a) (null? (cdr a)))) car)
  77.     (optional
  78.      (lambda (lambda (a) (or (null? a) (and (pair? a) (null? (cdr a))))))
  79.      identity)
  80.     (boolean
  81.      (lambda (a) (or (null? a)
  82.              (and (pair? a) (null? (cdr a)) (boolean? (car a)))))
  83.      (lambda (a) (if (null? a) #f (car a))))
  84.     (nary (lambda (a) #t) identity)
  85.     (nary1 (lambda (a) (not (null? a))) identity))))
  86.     (for-each (((rdb 'open-table) '*domains-data* #t) 'row:insert)
  87.           '((parameter-list *catalog-data* #f symbol 1)
  88.         (parameter-name-translation *catalog-data* #f symbol 1)
  89.         (parameter-arity parameter-arity #f symbol 1)
  90.         (table *catalog-data* #f atom 1)))
  91.     (dbutil:define-tables
  92.      rdb
  93.      '(*parameter-columns*
  94.        *columns*
  95.        *columns*
  96.        ((1 #t index #f uint)
  97.     (2 #f name #f symbol)
  98.     (3 #f arity #f parameter-arity)
  99.     (4 #f domain #f domain)
  100.     (5 #f defaulter #f expression)
  101.     (6 #f expander #f expression)
  102.     (7 #f documentation #f string)))
  103.      '(no-parameters
  104.        *parameter-columns*
  105.        *parameter-columns*
  106.        ())
  107.      '(no-parameter-names
  108.        ((name string))
  109.        ((parameter-index uint))
  110.        ())
  111.      '(add-domain-params
  112.        *parameter-columns*
  113.        *parameter-columns*
  114.        ((1 domain-name single atom #f #f "new domain name")
  115.     (2 foreign-table optional table #f #f
  116.        "if present, domain-name must be existing key into this table")
  117.     (3 domain-integrity-rule optional expression #f #f
  118.        "returns #t if single argument is good")
  119.     (4 type-id single type #f #f "base type of new domain")
  120.     (5 type-param optional expression #f #f
  121.        "which (key) field of the foreign-table")
  122.     ))
  123.      '(add-domain-pnames
  124.        ((name string))
  125.        ((parameter-index uint))        ;should be add-domain-params
  126.        (
  127.     ("n" 1) ("name" 1)
  128.     ("f" 2) ("foreign (key) table" 2)
  129.     ("r" 3) ("domain integrity rule" 3)
  130.     ("t" 4) ("type" 4)
  131.     ("p" 5) ("type param" 5)
  132.     ))
  133.      '(del-domain-params
  134.        *parameter-columns*
  135.        *parameter-columns*
  136.        ((1 domain-name single domain #f #f "domain name")))
  137.      '(del-domain-pnames
  138.        ((name string))
  139.        ((parameter-index uint))        ;should be del-domain-params
  140.        (("n" 1) ("name" 1)))
  141.      '(*commands*
  142.        ((name symbol))
  143.        ((parameters parameter-list)
  144.     (parameter-names parameter-name-translation)
  145.     (procedure expression)
  146.     (documentation string))
  147.        ((domain-checker
  148.      no-parameters
  149.      no-parameter-names
  150.      (lambda (rdb)
  151.        (let* ((ro:domains ((rdb 'open-table) '*domains-data* #f))
  152.           (ro:get-dir (ro:domains 'get 'domain-integrity-rule))
  153.           (ro:for-tab (ro:domains 'get 'foreign-table)))
  154.          (lambda (domain)
  155.            (let ((fkname (ro:for-tab domain))
  156.              (dir (slib:eval (ro:get-dir domain))))
  157.          (if fkname (let* ((fktab ((rdb 'open-table) fkname #f))
  158.                    (p? (fktab 'get 1)))
  159.                   (if dir (lambda (e) (and (dir e) (p? e))) p?))
  160.              dir)))))
  161.      "return procedure to check given domain name")
  162.  
  163.     (add-domain
  164.      add-domain-params
  165.      add-domain-pnames
  166.      (lambda (rdb)
  167.        (((rdb 'open-table) '*domains-data* #t) 'row:update))
  168.      "add a new domain")
  169.  
  170.     (delete-domain
  171.      del-domain-params
  172.      del-domain-pnames
  173.      (lambda (rdb)
  174.        (((rdb 'open-table) '*domains-data* #t) 'row:remove))
  175.      "delete a domain"))))
  176.     (let* ((tab ((rdb 'open-table) '*domains-data* #t))
  177.        (row ((tab 'row:retrieve) 'type)))
  178.       (set-car! (cdr row) 'type)
  179.       ((tab 'row:update) row))
  180.     (dbutil:wrap-command-interface rdb)))
  181.  
  182. (define (make-command-server rdb command-table)
  183.   (let* ((comtab ((rdb 'open-table) command-table #f))
  184.      (names (comtab 'column-names))
  185.      (row-ref (lambda (row name) (list-ref row (position name names))))
  186.      (comgetrow (comtab 'row:retrieve)))
  187.     (lambda (comname command-callback)
  188.       (let* ((command:row (comgetrow comname))
  189.          (parameter-table
  190.           ((rdb 'open-table) (row-ref command:row 'parameters) #f))
  191.          (parameter-names
  192.           ((rdb 'open-table) (row-ref command:row 'parameter-names) #f))
  193.          (comval ((slib:eval (row-ref command:row 'procedure)) rdb))
  194.          (options ((parameter-table 'get* 'name)))
  195.          (positions ((parameter-table 'get* 'index)))
  196.          (arities ((parameter-table 'get* 'arity)))
  197.          (defaulters (map slib:eval ((parameter-table 'get* 'defaulter))))
  198.          (domains ((parameter-table 'get* 'domain)))
  199.          (types (map (((rdb 'open-table) '*domains-data* #f) 'get 'type-id)
  200.              domains))
  201.          (dirs (map (rdb 'domain-checker) domains))
  202.          (aliases
  203.           (map list ((parameter-names 'get* 'name))
  204.            (map (parameter-table 'get 'name)
  205.             ((parameter-names 'get* 'parameter-index))))))
  206.     (command-callback comname comval options positions
  207.               arities types defaulters dirs aliases)))))
  208.  
  209. (define (dbutil:define-tables rdb . spec-list)
  210.   (define new-tables '())
  211.   (define dom:typ (((rdb 'open-table) '*domains-data* #f) 'get 4))
  212.   (define create-table (rdb 'create-table))
  213.   (define open-table (rdb 'open-table))
  214.   (define table-exists? (rdb 'table-exists?))
  215.   (define (check-domain dname)
  216.     (cond ((dom:typ dname))
  217.       ((member dname new-tables)
  218.        (let* ((ftab (open-table
  219.              (string->symbol
  220.               (string-append "desc:" (symbol->string dname)))
  221.              #f)))
  222.          ((((rdb 'open-table) '*domains-data* #t) 'row:insert)
  223.           (list dname dname #f
  224.             (dom:typ ((ftab 'get 'domain-name) 1)) 1))))))
  225.   (define (define-table name prikeys slots data)
  226.     (cond
  227.      ((table-exists? name)
  228.       (let* ((tab (open-table name #t))
  229.          (row:update (tab 'row:update)))
  230.     (for-each row:update data)))
  231.      ((and (symbol? prikeys) (eq? prikeys slots))
  232.       (cond ((not (table-exists? slots))
  233.          (slib:error "Table doesn't exist:" slots)))
  234.       (set! new-tables (cons name new-tables))
  235.       (let* ((tab (create-table name slots))
  236.          (row:insert (tab 'row:insert)))
  237.     (for-each row:insert data)
  238.     ((tab 'close-table))))
  239.      (else
  240.       (let* ((descname
  241.           (string->symbol (string-append "desc:" (symbol->string name))))
  242.          (tab (create-table descname))
  243.          (row:insert (tab 'row:insert))
  244.          (j 0))
  245.     (set! new-tables (cons name new-tables))
  246.     (for-each (lambda (des)
  247.             (set! j (+ 1 j))
  248.             (check-domain (cadr des))
  249.             (row:insert (list j #t (car des)
  250.                       (if (null? (cddr des)) #f (caddr des))
  251.                       (cadr des))))
  252.           prikeys)
  253.     (for-each (lambda (des)
  254.             (set! j (+ 1 j))
  255.             (check-domain (cadr des))
  256.             (row:insert (list j #f (car des)
  257.                       (if (null? (cddr des)) #f (caddr des))
  258.                       (cadr des))))
  259.           slots)
  260.     ((tab 'close-table))
  261.     (set! tab (create-table name descname))
  262.     (set! row:insert (tab 'row:insert))
  263.     (for-each row:insert data)
  264.     ((tab 'close-table))))))
  265.   (for-each (lambda (spec) (apply define-table spec)) spec-list))
  266.  
  267. (define create-database dbutil:create-database)
  268. (define open-database! dbutil:open-database!)
  269. (define open-database dbutil:open-database)
  270. (define define-tables dbutil:define-tables)
  271.